;;; -*- Mode:Lisp; Package:OOGA; Base:10; Syntax:COMMON-LISP -*-
#||
			RESTRICTED RIGHTS LEGEND
				    
 Use, duplication, or disclosure by the Government is subject to
 restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
 Technical Data and Computer Software Clause at 52.227-7013 of the DOD
 FAR Supplement.
				    
				TSP (The Software Partnership)
				P.O. Box 991
				Melrose, MA 02176
				    
      Copyright 1990 by Lawrence Davis and Daniel Cerys, all rights reserved.
||#
 
(in-package :ooga)


;************************************************************

;	PROBLEM 1:  F6 (THE SINE ENVELOPE SIN WAVE)



(defun F6 (x1 x2)
  "Inverted F6 from Shaffer et al's test suite -- the sine envelope sin wave"
  (let* ((sum-of-squares (+ (* x1 x1) (* x2 x2)))
	 (numerator-sin (sin (sqrt sum-of-squares)))
	 (denominator-amount (+ 1.0 (* .001 sum-of-squares))))
    (+ 0.5
       (/ (- (* numerator-sin numerator-sin) 0.5)
	  (* denominator-amount denominator-amount)))))


;;; F6 in binary

(defclass BINARY-F6
	  (evaluator)
  ())


(defmethod EVALUATE-MEMBER ((evaluator binary-f6) population-member)
    (let* ((raw-x1 (coerce (convert-bit-string-to-integer
			     (firstn 22 (chromosome population-member)))
		   'double-float))
	   (raw-x2 (coerce (convert-bit-string-to-integer
		     (nthcdr 22 (chromosome population-member)))
		   'double-float))
	   (x1 (- (* raw-x1 4.768372718899898d-5) 100))
	   (x2 (- (* raw-x2 4.768372718899898d-5) 100)))
      (- 1.0 (f6 x1 x2))))


;;; F6 in binary with values increased by 999.

(defclass ELEVATED-BINARY-F6
	  (evaluator)
  ())


(defmethod EVALUATE-MEMBER ((evaluator elevated-binary-f6) population-member)
    (let* ((raw-x1 (coerce (convert-bit-string-to-integer
			     (firstn 22 (chromosome population-member)))
		   'double-float))
	   (raw-x2 (coerce (convert-bit-string-to-integer
		     (nthcdr 22 (chromosome population-member)))
		   'double-float))
	   (x1 (- (* raw-x1 4.768372718899898d-5) 100))
	   (x2 (- (* raw-x2 4.768372718899898d-5) 100)))
      (- 1000.0 (f6 x1 x2))))



;;; F6 with real numbers.

(defclass REAL-NUMBER-F6
	  (evaluator)
  ())


(defmethod EVALUATE-MEMBER ((evaluator real-number-f6) population-member)
    (let* ((x1 (- (* (car (chromosome population-member))
		     4.768372718899898d-5) 100))
	   (x2 (- (* (cadr (chromosome population-member))
		     4.768372718899898d-5) 100)))
      (- 1.0 (f6 x1 x2))))


;**************************************************
;**************************************************


;	NODE COLORING PROBLEM



;**************************************************

;	GRAPH ROUTINES



;**************************************************

;	BASIC CLASS DEFINITIONS


;A GRAPH contains a list of nodes and a list of edges.
;The nodes are of class node-class.  The edges are not
;explicitly represented.

(defclass GRAPH
	  ()
     ((NODES :initarg :nodes :initform nil :accessor nodes)))


;Vanilla NODE class.  There is an index (could be a name),
;a list of neighbors, and a list of attached edges.

(defclass NODE
	  ()
     ((index :initarg :index :reader index)
      (neighbors :initform nil :initarg :neighbors :accessor neighbors)))


;**************************************************

;	GRAPH COLORING NODE


;Vanilla node with weight.  Default is 1.
(defclass GRAPH-COLORING-NODE
	  (node)
     ((WEIGHT :initform 1 :initarg :weight :reader weight)
      (COLOR :initarg :color :initform nil :accessor color)))


;**************************************************

;	RANDOM GRAPH CREATION ROUTINES


;	GRAPH SPECS


(defun MAKE-GRAPH-SPECS (node-number edge-number)
  "Randomly create graph specs."
  (let* ((node-specs (loop for n from 1 to node-number
			      collect (list n (+ 60 (random 200)))))
	 (edge-specs (make-edge-specs node-number edge-number)))
    (loop for node-spec in node-specs
	  for edge-spec in edge-specs
	  collect (append node-spec
			  (list (sort (get-connected-nodes
					(car node-spec) edge-specs)
				      (function (lambda (x y) (< x y)))
				      ))))))


(defun MAKE-EDGE-SPECS (node-number edge-number)
  "Create edge specs."
  (loop with node-indices = (loop for x from 1 to node-number collect x)
	with edges = nil
	for index1 = (random-member node-indices)
	for index2 = (random-member node-indices)
	for new-edge = (if (> index1 index2)
			   (list index2 index1)
			   (list index1 index2))
	until (>= (length edges) edge-number)
	do (unless (or (= index1 index2)
		       (loop for edge in edges
			     thereis (equal edge new-edge)))
	     (setf edges (cons new-edge edges)))
	finally (return edges)))



(defun GET-CONNECTED-NODES (node-index edge-specs)
  "Find the nodes connected to the node with the given index."
  (loop for spec in edge-specs
	when (member node-index spec)
	collect (other-index node-index spec) into neighbors
	finally (return neighbors)))


(defun OTHER-INDEX (index spec)
  "Get the index of the other node in the spec"
  (if (= index (car spec)) (cadr spec) (car spec)))


(defmethod MAKE-AND-LINK-NODES (node-specs)
  "Make the nodes from the specs"
  (let ((nodes (loop for spec in node-specs
		     collect (make-instance 'graph-coloring-node
					    :index (car spec)
					    :weight (cadr spec)))))
    (loop for node in nodes
	  for neighbor-indices = (third (assoc (index node) node-specs))
	  do (setf (neighbors node) (get-nodes-with-indices nodes neighbor-indices)))
    nodes))


(defun GET-NODES-WITH-INDICES (nodes indices)
  "Find the nodes with the given indices"
  (loop for index in indices
	collect (loop for node in nodes
		      when (= (index node) index)
		      do (return node)
		      finally (format *standard-output* "~%No Node With Index ~a" index))))


(defun MAKE-GRAPH-FROM-SPECS (node-specs)
  "Make the graph from the specs"
  (let ((graph (make-instance 'graph)))
    (setf (nodes graph) (make-and-link-nodes node-specs))
    graph))


;**************************************************

;	SPECS FOR 100-NODE GRAPH

;; Best solution found = 10413 
;; with a 320/4000 version of GA 6-1.


(defvar *GRAPH-SPECS*
	'(
   (1 62 (20 58 74 82)) 
   (2 183 (6 12 20 28 29 32 51 53 56 70 79 84 94)) 
   (3 247 (18 24 33 50 88 92)) 
   (4 66 (70 74 75 79 95 98)) 
   (5 181 (7 25 32 34 44 55 69 85)) 
   (6 95 (2 62 67 84 91)) 
   (7 112 (5 43 47 82 84)) 
   (8 65 (10 20 25 71 72 91)) 
   (9 163 (32 44 46 62 67 69 71 82 92)) 
   (10 112 (8 34 40 43 76 83 88 93)) 
   (11 153 (12 18 23 26 30 73 82 97)) 
   (12 117 (2 11 16 17 25 31 36 44 69 71 72 80 84)) 
   (13 163 (28 29 38 61 67 77 92)) 
   (14 239 (25 33 61 92)) 
   (15 193 (19 25 38 56 57 67 88 96 100)) 
   (16 241 (12 25 40 42 64 68)) 
   (17 255 (12 23 30 39 79 82)) 
   (18 153 (3 11 36 58 59 73 80 90 96)) 
   (19 191 (15 31 35 47 49)) 
   (20 209 (1 2 8 31 61 73 100)) 
   (21 97 (22 27 28 32 88 93)) 
   (22 133 (21 52 63 71 82 89 94 100)) 
   (23 84 (11 17 25 37 49 62 71 84 90 93)) 
   (24 103 (3 26 43 55 56 58 66 72 98)) 
   (25 81 (5 8 12 14 15 16 23 36 61 63 75 87)) 
   (26 104 (11 24 37 41 46 53 64 68 94)) 
   (27 220 (21 29 32 40 53 65 74 78)) 
   (28 208 (2 13 21 42 68 72 79 87)) 
   (29 187 (2 13 27 40 43 60 64 71 99 100)) 
   (30 129 (11 17 52 54 60 67)) 
   (31 65 (12 19 20 39 42 56 71 78 83 89 90 93)) 
   (32 181 (2 5 9 21 27 35 37 38 49 50 68 73 79)) 
   (33 141 (3 14 35 36 40 49 62 76)) 
   (34 118 (5 10 36 41 55 87 100)) 
   (35 81 (19 32 33 38 40 44 55 77)) 
   (36 70 (12 18 25 33 34 46 50 53 70 78 81 91)) 
   (37 210 (23 26 32 60 88 97)) 
   (38 95 (13 15 32 35 50 60 61 78 88)) 
   (39 103 (17 31 64 77)) 
   (40 187 (10 16 27 29 33 35 51 53 82 86)) 
   (41 121 (26 34 81 96)) 
   (42 97 (16 28 31 51 56 75 76 78 87 94)) 
   (43 130 (7 10 24 29 70)) 
   (44 113 (5 9 12 35 70 74 81 91 100)) 
   (45 169 (53 78 81 86)) 
   (46 182 (9 26 36 50 54 59 63 83 92 96 98)) 
   (47 232 (7 19 64 77 84 92)) 
   (48 233 (49 84 88)) 
   (49 250 (19 23 32 33 48 59 60 68 77 83 89 91)) 
   (50 220 (3 32 36 38 46 55 57 84 86 87 97)) 
   (51 117 (2 40 42 57 69 98)) 
   (52 126 (22 30 61 81 84 99)) 
   (53 84 (2 26 27 36 40 45 54 55 93 97 99)) 
   (54 182 (30 46 53 57 58 69 95)) 
   (55 145 (5 24 34 35 50 53 79 87)) 
   (56 176 (2 15 24 31 42 67 71 89 92)) 
   (57 241 (15 50 51 54 62 65)) 
   (58 178 (1 18 24 54 59 67 79 88)) 
   (59 226 (18 46 49 58 64 82)) 
   (60 242 (29 30 37 38 49 62 82 90 91 100)) 
   (61 153 (13 14 20 25 38 52 70 77 86)) 
   (62 79 (6 9 23 33 57 60 63 77 88)) 
   (63 236 (22 25 46 62 68 72 85 94 98)) 
   (64 106 (16 26 29 39 47 59 76 85 96)) 
   (65 218 (27 57 82 96)) 
   (66 205 (24 67 84 96 97)) 
   (67 154 (6 9 13 15 30 56 58 66 76 99)) 
   (68 221 (16 26 28 32 49 63 69 79)) 
   (69 164 (5 9 12 51 54 68 79 89)) 
   (70 104 (2 4 36 43 44 61 77)) 
   (71 105 (8 9 12 22 23 29 31 56 88 95)) 
   (72 212 (8 12 24 28 63 86 87 97)) 
   (73 218 (11 18 20 32 84 85 93 97)) 
   (74 90 (1 4 27 44 77 88 92 95)) 
   (75 193 (4 25 42 81 99)) 
   (76 242 (10 33 42 64 67 78 85 86)) 
   (77 236 (13 35 39 47 49 61 62 70 74 80 93 95)) 
   (78 86 (27 31 36 38 42 45 76 93)) 
   (79 118 (2 4 17 28 32 55 58 68 69 96)) 
   (80 72 (12 18 77 94 99)) 
   (81 234 (36 41 44 45 52 75 97)) 
   (82 125 (1 7 9 11 17 22 40 59 60 65 88 94 98)) 
   (83 90 (10 31 46 49)) 
   (84 153 (2 6 7 12 23 47 48 50 52 66 73 93 95 99)) 
   (85 199 (5 63 64 73 76 88)) 
   (86 154 (40 45 50 61 72 76 87 89 91 93)) 
   (87 107 (25 28 34 42 50 55 72 86 100)) 
   (88 79 (3 10 15 21 37 38 48 58 62 71 74 82 85)) 
   (89 75 (22 31 49 56 69 86 96 99)) 
   (90 76 (18 23 31 60)) 
   (91 229 (6 8 36 44 49 60 86)) 
   (92 182 (3 9 13 14 46 47 56 74)) 
   (93 251 (10 21 23 31 53 73 77 78 84 86 97)) 
   (94 250 (2 22 26 42 63 80 82 97)) 
   (95 85 (4 54 71 74 77 84)) 
   (96 174 (15 18 41 46 64 65 66 79 89)) 
   (97 219 (11 37 50 53 66 72 73 81 93 94)) 
   (98 100 (4 24 46 51 63 82)) 
   (99 254 (29 52 53 67 75 80 84 89)) 
   (100 145 (15 20 22 29 34 44 60 87)) 
 ))


;**************************************************

;	DISPLAY METHODS


(defmethod DISPLAY ((graph graph))
  "Display the nodes and edges."
  (format *standard-output* "~%~%GRAPH NODES IN FORMAT INDEX / WEIGHT / COLOR / NEIGHBORS~%")
  (loop for node in (nodes graph)
	do (display node)))


(defmethod DISPLAY ((node node))
  (format *standard-output* "~%  ~a    ~a   ~a    ~a"
	  (index node)
	  (weight node)
	  (if (color node) (color node) '-)
	  (loop for neighbor in (neighbors node)
		collect (index neighbor))))



;*******************************************************

;	NODE COLORING EVALUATOR


;;; The evaluator for Chapter 6 of the Handbook.

(defclass NODE-COLORING-EVALUATOR
	  (evaluator)
  ((GRAPH :initarg :graph :initform (make-graph-from-specs *graph-specs*)
	  :accessor graph)
   (COLORS :initarg :colors :initform '(A B) :accessor colors)
   ))


;;; Return the list to be permuted

(defmethod LIST-TO-PERMUTE ((evaluator node-coloring-evaluator))
  (copy-list (nodes (graph evaluator))))


;;; Color the nodes from the chromosome and add the weight of colored nodes.

(defmethod EVALUATE-MEMBER ((evaluator node-coloring-evaluator) population-member)
  (reset-for-evaluation (graph evaluator))
  (loop for node in (chromosome population-member)
	with colors = (colors evaluator)
	do (give-node-first-legal-color node colors))
  (loop for node in (nodes (graph evaluator))
	summing (if (color node) (weight node) 0)))


(defmethod RESET-FOR-EVALUATION ((graph graph))
  "Reset for evaluation"
  (loop for node in (nodes graph)
	do (setf (color node) nil)))


(defmethod GIVE-NODE-FIRST-LEGAL-COLOR ((node graph-coloring-node) colors)
  "Assign the node the first color that isn't the color of a neighboring node."
  (loop for color in colors
	with neighbors = (neighbors node)
	when (not (already-colored color neighbors))
	do (return (setf (color node) color))))


(defun ALREADY-COLORED (color neighbors)
  "Is there a neighbor with this color?"
  (loop for neighbor in neighbors
	thereis (eq color (color neighbor))))




